COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 2 Way Matcher
C00010 ENDMK
C⊗;
;;; 2 Way Matcher
;;; Here are the macros which define the simple tree structure case

(DECLARE (SETQ DEFMACRO-FOR-COMPILING ()) (MAPEX T)
	 (FASLOAD STRUCT FAS DSK (MAC LSP)))

(DEFMACRO CONSP (X) `(EQ (TYPEP ,X) 'LIST))

(DEFMACRO P-ATOMIC (X) `(ATOM ,X))

(DEFMACRO P-UNDECOMPOSABLE (X)
	  `(OR (ATOM ,X) 
	       (HUNKP ,X)))

(DEFMACRO P-CURRENT (X) `(CAR ,X))

(DEFMACRO P-ADVANCE (X) `(CDR ,X))

(DEFMACRO P-VAR-TYPE (ATOM) 
	  ;; returns the 1st character of an atom.
	  `(COND ((EQ (TYPEP ,ATOM) 'SYMBOL) (GETCHAR ,ATOM 1.))))

(DEFMACRO P-CHANGE-CURRENT (X Y) `(CONS ,Y (CDR ,X)))

(DEFMACRO P-CHANGE (X Y) Y)

(DEFMACRO P-RESTRICT-VAR (X) `(CADR ,X))

(DEFUN P-MAP-BUILD (FUN LIST)
       (COND ((NULL LIST) ())
	     (T (CONS (FUNCALL FUN (CAR LIST))
		      (P-MAP-BUILD FUN (CDR LIST))))))

(DEFMACRO P-CURRENT-EMPTY (X) `(NULL (CAR ,X)))

(DEFMACRO P-EMPTY (X) `(NULL ,X))

(DEFMACRO P-LISTIFY (X) X)

(DEFMACRO P-LISTIFY-REST (X) `(CDR ,X))

(DEFMACRO P-RESTRICT-FUNS (X) `(CDDR ,X))

(DEFMACRO P-RESTRICTP (%/#X) `(AND (NOT (ATOM ,%/#X))
				   (MEMQ (CAR ,%/#X) 
					 '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR))))

(DEFMACRO P-IRESTRICTP (%/#X) `(AND (NOT (ATOM ,%/#X))
				   (MEMQ (CAR ,%/#X) 
					 '($IR IRESTRICT ⊗IR))))

(DEFMACRO P-FRESTRICTP (%/#X) `(AND (NOT (ATOM ,%/#X))
				   (MEMQ (CAR ,%/#X) 
					 '($R RESTRICT ⊗R))))

(DEFMACRO P-RESTRICT-VAR (X) `(CADR ,X))

(DEFMACRO P-RESTRICT-TYPE (X) `(CAR ,X))

(DEFMACRO P-CREATE-RESTRICTION (X Y Z)
	  `(CONS ,X (CONS ,Y  ,Z)))

(DEFMACRO P-ADD-ITEM (X ITEMS)
	  `(CONS ,ITEMS ,X))

(DEFMACRO P-ADD-ITEMS (X ITEMS)
	  `(APPEND ,ITEMS ,X))

(DEFMACRO P-REST-EMPTY (X) `(NULL (CDR ,X)))

(DEFMACRO P-CREATE-STATE (X) X)

(DEFMACRO P-CHANGE-CURRENT-ITEMS (X ITEMS)
	  `(APPEND ,ITEMS (CDR ,X)))

(DEFMACRO P-CREATE-NULL-STATE () ())

(DEFMACRO P-CREATE-STATE-FROM-CURRENT (X) `(CAR ,X))

(DEFMACRO P-CURRENT-ATOMIC (X) `(ATOM (CAR ,X)))

(DECLARE (SPECIAL -SEENR- -SEEN-))

(DEFUN P-CHECK (L)
  ((LAMBDA (-SEEN- -SEENR-)
    (P-CHECK1 L)) ()())) 

(DEFUN P-CHECK1 (L)
 (COND ((MEMQ L -SEENR-) (P-CURRENT L))
       ((P-UNDECOMPOSABLE L) (PUSH (P-CURRENT-OBJECT L) -SEENR-)
			     (PUSH L -SEENR-)
			     (P-CURRENT-OBJECT L))
       ((P-ATOMIC L) (P-CURRENT-OBJECT L))
       ((AND (CONSP (P-CURRENT L))
	     (EQ (P-CURRENT L) '-SPECIAL-FORM-))
	(P-ADVANCE L))
       (T 
	(LET ((X (P-MAP-BUILD #'P-CHECK1 L)))
	     (PUSH L -SEENR-)
	     (PUSH X -SEEN-) X)))) 

(EVAL-WHEN (COMPILE EVAL)
	   (DEFSTRUCT CHOOSER PAST-CHOICES ORIGINAL-DATA VARIABLE PREDICATES CHOICE EMPTY
		      SEARCH-LIST
		      CONSTANTP))

(DEFMACRO P-CHOOSEP (X) `(AND (NOT (ATOM ,X))
			      (MEMQ (CAR ,X) '($CHOOSE $CH))))

(DEFMACRO P-CHOOSE-VAR (X) `(CADR ,X))

(DEFMACRO P-EMPTY-CHOICE (X) `(EMPTY ,X))

(DEFMACRO COPY (X) `(MAPCAR #'(LAMBDA (X) X) ,X))

(DEFUN P-CHOOSE-FIRST (P D)
       (P-CHOOSER
	(MAKE-CHOOSER PAST-CHOICES () ORIGINAL-DATA D
		      CONSTANTP (ATOM P)
		      SEARCH-LIST D
		      CHOICE ()
		      EMPTY ()
		      VARIABLE (COND ((ATOM P) P)
				     (T (CADR P)))
		      PREDICATES (COND ((ATOM P) ())
				       (T (CDDR P))))))

(DEFUN P-CHOOSE-NEXT (OLD-CHOOSER)
       (P-CHOOSER
       (MAKE-CHOOSER
	PAST-CHOICES (PAST-CHOICES OLD-CHOOSER) 
	ORIGINAL-DATA (ORIGINAL-DATA OLD-CHOOSER)
	CONSTANTP (CONSTANTP OLD-CHOOSER)
	SEARCH-LIST (SEARCH-LIST OLD-CHOOSER)
	CHOICE ()
	EMPTY ()
	VARIABLE (VARIABLE OLD-CHOOSER)
	PREDICATES (PREDICATES OLD-CHOOSER))))

(DEFMACRO P-NEXT-CHOICE (X) `(CHOICE ,X))

(DEFUN P-CHOOSER (CHOOSER)
 (LET ((P (VARIABLE CHOOSER))
       (D (COPY (ORIGINAL-DATA CHOOSER)))
       (SL (COPY (SEARCH-LIST CHOOSER))))
      (LET ((CH ()))
	   (COND ((CONSTANTP CHOOSER)
		  (COND ((SETQ SL (MEMQ P SL))
			 (SETQ CH `(,P . ,(DELQ P D))) 
			 (COND ((MEMBER CH (PAST-CHOICES CHOOSER))
				(SETF (EMPTY CHOOSER) T))
			       (T (SETF (CHOICE CHOOSER) CH)
				  (SETF (SEARCH-LIST CHOOSER) (CDR SL))
				  (SETF (PAST-CHOICES CHOOSER)
					`(,CH . ,(PAST-CHOICES CHOOSER))))))
			(T (SETF (EMPTY CHOOSER) T))))
		 (T (LET ((CAND (P-SEARCH (PREDICATES CHOOSER) SL)))
			 (COND (CAND
				(SETQ CH `(,(CAR CAND) 
					   . ,(DELQ (CAR CAND)
						      D)))
				(COND ((MEMBER CH (PAST-CHOICES CHOOSER))
				       (SETF (EMPTY CHOOSER) T)) 
				      (T (SETF (CHOICE CHOOSER) CH)
					 (SETF (SEARCH-LIST CHOOSER) (CDR CAND))
					 (SETF (PAST-CHOICES CHOOSER)
					       `(,CH . ,(PAST-CHOICES CHOOSER))))))
				     (T (SETF (EMPTY CHOOSER) T))))))))  
 CHOOSER)

(DEFUN P-SEARCH (PREDS L)
       (DO ((L L (CDR L)))
	   ((NULL L) ())
	   (COND ((APPLY 'AND
			 (MAPCAR #'(LAMBDA (F)
					   (FUNCALL F (CAR L)))
				 PREDS))
		  (RETURN L))))) 

(EVAL-WHEN (COMPILE EVAL)
	   (SSTATUS FEATURES SYMMETRIC)
	   (SSTATUS NOFEATURES TYPED)
	   (SSTATUS FEATURES NON-DETERMINISM))

(EVAL-WHEN (COMPILE EVAL)
	   (SETQ MATCH-PREFIX '%%
		 MATCH-NAME '%UMATCH))

(INCLUDE "GMATCH.125")